home *** CD-ROM | disk | FTP | other *** search
/ CU Amiga Super CD-ROM 27 / CU Amiga Magazine's Super CD-ROM 27 (1998)(EMAP Images)(GB)[!][issue 1998-10].iso / CUCD / Programming / JForth / JTools / IFF / test_pic < prev    next >
Encoding:
Text File  |  1992-01-28  |  2.5 KB  |  137 lines
  1. \ Test IFF Picture System
  2. ." You must create some IFF pictures first!" cr \ see below
  3.  
  4. include jiff:load_pic
  5. include? choose ju:random
  6.  
  7. ANEW TASK-TEST_PIC
  8.  
  9. \ You can replace these filenames with your own files if you like.
  10. : MOUNT_FILENAME " jpics:mountains.pic" ;
  11. : SHIP_FILENAME " jpics:ship.br" ; \ small UFO
  12. : COMET_FILENAME " jpics:comet.br" ;
  13.  
  14. picture MOUNT
  15. picture SHIP
  16. picture COMET
  17. picture BACKUP
  18.  
  19. : DUP.MOUNT ( -- , make copy of mountains )
  20.     mount backup pic.duplicate
  21.     mount backup pic.copy
  22. ;
  23.  
  24. : TPIC.TERM ( -- )
  25.     mount pic.free
  26.     ship pic.free
  27.     comet pic.free
  28.     backup pic.free
  29.     ' noop is pic.closebox
  30.     gr.term
  31. ;
  32.  
  33. : TPIC.BREAK  ( -- , stop and cleanup if closebox hit )
  34.     tpic.term
  35.     quit
  36. ;
  37.  
  38. : TPIC.INIT ( -- error? )
  39.     gr.init
  40.     pic-start-black on ( don't display at first , allow fadein )
  41. \
  42. \ You can't use PIC.LOAD here because you need a string.
  43.     mount_filename mount $pic.load? ?goto.error
  44.     ship_filename ship $pic.load? ?goto.error
  45. \
  46. \ the comet will have offsets based on the brush handle
  47.     pic-use-grabxy on  ( use handle to offset blit )
  48.     comet_filename comet $pic.load? ?goto.error
  49.     pic-use-grabxy off
  50. \
  51.     4 mount pic.fadein
  52.     dup.mount
  53. \
  54.     ' tpic.break is pic.closebox
  55.     false
  56.     exit
  57. \
  58. ERROR:
  59.     tpic.term
  60.     true
  61. ;
  62.  
  63. : TPIC.WIPE ( -- , wipe all 4 directions )
  64.     20  40 1 wipe_left  ship pic.wipe
  65.     120 40 1 wipe_right ship pic.wipe
  66.     70  100 1 wipe_up    ship pic.wipe
  67.     170 100 1 wipe_down  ship pic.wipe
  68. ;
  69.  
  70. : TPIC.ROTATE ( -- , flash colors by rotating bit planes )
  71.     mount pic.get.depth 2* 0
  72.     DO pic.rotate 4 wait.frames
  73.     LOOP
  74. ;
  75.  
  76. if.forgotten tpic.term
  77.  
  78. : BLIT.COMETS ( -- , blit random comets )
  79.     100 0
  80.     DO  mount pic.get.wh  ( -- w h )
  81.         choose swap choose swap  ( -- x y )
  82.         comet pic.trans.blit
  83.     LOOP
  84. ;
  85.  
  86. : TPIC.MOVE.SHIP ( -- , move ship using saved backgrounds )
  87.     0 ship pic.alloc.backup? 0=
  88.     IF
  89.         28 0
  90.         DO
  91.             -20 i 10 * +  30 i 2 * +
  92.             0 ship pic.backup.nth
  93.             -20 i 10 * +  30 i 2 * +
  94.             ship pic.trans.blit
  95.             10 wait.frames
  96.             0 ship pic.restore.nth
  97.         LOOP
  98.     THEN
  99. ;
  100.  
  101. : TPIC.DO.IT ( -- )
  102.     0 gr.mode!  ( text drawing mode )
  103.     4 gr.color!
  104.     60 40 " JForth Picture Test" gr.xytext
  105.     1 gr.color!
  106.     100 wait.frames
  107. \
  108.     tpic.wipe
  109.     100 wait.frames
  110. \
  111.     2 mount pic.fadeout
  112.     0 0 backup pic.blit  ( restore image )
  113.     1 mount pic.fadein
  114.     100 wait.frames
  115. \
  116.     tpic.rotate
  117.     100 wait.frames
  118. \
  119.     blit.comets
  120.     100 wait.frames
  121. \
  122.     2 mount pic.fadeout
  123.     0 0 backup pic.blit  ( restore image )
  124.     1 mount pic.fadein
  125.     tpic.move.ship
  126. ;
  127.  
  128. : TEST.PIC ( -- )
  129.     tpic.init 0=
  130.     IF
  131.         tpic.do.it
  132.         tpic.term
  133.     THEN
  134. ;
  135.  
  136. cr ." Enter: TEST.PIC    to see demo." cr
  137.